home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue58 / EasyWeb / Enhcalnd.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-03-27  |  27.0 KB  |  880 lines
  1. { *****************************************************
  2.               TCalendarLabel Component
  3.  
  4.   The TRngSelCalendar component is an improved version of the
  5.   calendar provided on the Samples page of Delphi 1.02.
  6.   Improvements include the ability to store strings in
  7.   the cells, provide foreground color for occupied cells
  8.   and drag/drop abilities.
  9.  
  10.   The TCalendarLabel component attaches to a TRngSelCalendar and
  11.   displays the month and year. TCalLabel responds to the
  12.   HookEvent event. See unit EList.pas for details.
  13.  
  14.                   Paul Warren
  15.          HomeGrown Software Development
  16.        (c) 1997 Langley British Columbia.
  17.                 (604) 856-6523
  18.          e-mail:  hg_soft@uniserve.com
  19.     Home page: http://users.uniserve.com/~hg_soft
  20.   ***************************************************** }
  21.  
  22. unit Enhcalnd;
  23.  
  24. interface
  25.  
  26. uses
  27.   {$IFDEF WIN32}
  28.   Windows,
  29.   {$ELSE}
  30.   Wintypes, WinProcs,
  31.   {$ENDIF}
  32.   Classes, Controls, Messages, Forms, Graphics, StdCtrls,
  33.      Grids, SysUtils, Menus, ExtCtrls, EList;
  34.  
  35. type
  36.   TDayOfWeek = 0..6;
  37.  
  38.   TMonthChange = procedure(Sender: TObject; Month: Integer) of object;
  39.   TYearChange = procedure(Sender: TObject; Year: Integer) of object;
  40.   TDateChange = procedure(Sender: TObject; NewDate: TDateTime) of object;
  41.   TDroppedCell = procedure(Sender: TObject; ACol, ARow: LongInt;
  42.     var Value: string) of object;
  43.   TCellDragOver = procedure(Sender, Source: TObject; X, Y: Integer;
  44.     State: TDragState; var Accept: Boolean) of object;
  45.  
  46.   TBaseCalendar = class(TCustomGrid)
  47.   private
  48.     { Private declarations }
  49.     FBlockWeekends: Boolean;
  50.     FBlockedColor: TColor;
  51.     FDate: TDateTime;
  52.     FFixedHeader: Boolean;
  53.     FMonthOffset: Integer;
  54.     FReadOnly: Boolean;
  55.     FStartOfWeek: TDayOfWeek;
  56.     FUpdating: Boolean;
  57.     FMonthChange: TMonthChange;
  58.     FYearChange: TYearChange;
  59.     FDateChange: TDateChange;
  60.     FEventList: TEventList;
  61.     FHookEvent: TNotifyEvent;
  62.     function GetCellText(ACol, ARow: Integer): string;
  63.     function GetDateElement(Index: Integer): Integer;
  64.     procedure SetBlockWeekends(Value: Boolean);
  65.     procedure SetBlockedColor(Value: TColor);
  66.     procedure SetCalendarDate(Value: TDateTime);
  67.     procedure SetDateElement(Index: Integer; Value: Integer);
  68.     procedure SetFixedHeader(Value: Boolean);
  69.     procedure SetStartOfWeek(Value: TDayOfWeek);
  70.     procedure SetHookEvent(Value: TNotifyEvent);
  71.   protected
  72.     { Protected declarations }
  73.     procedure Loaded; override;
  74.     procedure Click; override;
  75.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  76.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  77.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  78.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  79.   public
  80.     { Public declarations }
  81.     constructor Create(AOwner: TComponent); override;
  82.     destructor Destroy; override;
  83.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  84.     procedure NextMonth;
  85.     procedure NextYear;
  86.     procedure PrevMonth;
  87.     procedure PrevYear;
  88.     function DaysThisMonth: Integer;
  89.     function IsWeekend(ADay: integer): boolean;
  90.     procedure UpdateCalendar; virtual;
  91.     function GetComponentImage: TBitmap;
  92.     procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  93.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  94.     property CalendarDate: TDateTime read FDate write SetCalendarDate stored false;
  95.     property Day: Integer index 3 read GetDateElement write SetDateElement stored false;
  96.     property Month: Integer index 2  read GetDateElement write SetDateElement stored false;
  97.     property Year: Integer index 1  read GetDateElement write SetDateElement stored false;
  98.     property BlockWeekends: Boolean read FBlockWeekends write SetBlockWeekends default false;
  99.     property BlockedColor: TColor read FBlockedColor write SetBlockedColor default clGray;
  100.     property FixedHeader: Boolean read FFixedHeader write SetFixedHeader default True;
  101.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  102.     property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
  103.     property OnDateChange: TDateChange read FDateChange write FDateChange;
  104.     property OnMonthChange: TMonthChange read FMonthChange write FMonthChange;
  105.     property OnYearChange: TYearChange read FYearChange write FYearChange;
  106.     property HookEvent: TNotifyEvent write SetHookEvent;
  107.   published
  108.     { Published declarations }
  109.   end;
  110.  
  111.   TCalendarStrings = array[0..6, 0..6] of TStringList;
  112.   TNeedStrings = procedure(Sender: TObject; ACol, ARow: LongInt;
  113.     ADate: TDateTime; var Value: TStringList) of object;
  114.  
  115.   TStringsCalendar = class(TBaseCalendar)
  116.   private
  117.     { Private declarations }
  118.     FCalStrings: TCalendarStrings;
  119.     FOnDroppedCell: TDroppedCell;
  120.     FOnCellDragOver: TCellDragOver;
  121.     FOnNeedStrings: TNeedStrings;
  122.     function GetCalStrings(ACol, ARow: integer): TStringList; virtual;
  123.     procedure SetCalStrings(ACol, ARow: Integer; Value: TStringList); virtual;
  124.     procedure SetCellString(ACol, ARow, ADay: Integer; Value: string); virtual;
  125.   protected
  126.     { Protected declarations }
  127.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  128.     procedure AcceptDropped(Sender, Source: TObject; X, Y: integer);
  129.     procedure CellDragOver(Sender, Source: TObject; X, Y: Integer;
  130.       State: TDragState; var Accept: Boolean);
  131.   public
  132.     { Public declarations }
  133.     constructor Create(AOwner: TComponent); override;
  134.     destructor Destroy; override;
  135.     procedure ClearAllDays;
  136.     property CellString[ACol, ARow, ADay: Integer]: string write SetCellString;
  137.     property CalStrings[ACol, ARow: Integer]: TStringList read GetCalStrings write SetCalStrings;
  138.   published
  139.     { Published declarations }
  140.     property OnDroppedCell: TDroppedCell read FOnDroppedCell write FOnDroppedCell;
  141.     property OnCellDragOver: TCellDragOver read FOnCellDragOver write FOnCellDragOver;
  142.     property OnNeedStrings: TNeedStrings read FOnNeedStrings write FOnNeedStrings;
  143.     property BlockWeekends;
  144.     property BlockedColor;
  145.     property FixedHeader;
  146.     property ReadOnly;
  147.     property StartOfWeek;
  148.     property OnDateChange;
  149.     property OnMonthChange;
  150.     property OnYearChange;
  151.     property Align;
  152.     property BorderStyle;
  153.     property Color;
  154.     property Ctl3D;
  155.     property DragCursor;
  156.     property DragMode;
  157.     property Enabled;
  158.     property FixedColor;
  159.     property Font;
  160.     property ParentColor;
  161.     property ParentCtl3D;
  162.     property ParentFont;
  163.     property ParentShowHint;
  164.     property PopupMenu;
  165.     property ShowHint;
  166.     property TabOrder;
  167.     property TabStop;
  168.     property Visible;
  169.     property OnClick;
  170.     property OnDblClick;
  171.     property OnEndDrag;
  172.     property OnEnter;
  173.     property OnExit;
  174.     property OnKeyDown;
  175.     property OnKeyPress;
  176.     property OnKeyUp;
  177.     property OnMouseDown;
  178.     property OnMouseMove;
  179.     property OnMouseUp;
  180.   end;
  181.  
  182.   TRngSelCalendar = class(TStringsCalendar)
  183.   private
  184.     { private declarations }
  185.     FRangeColor: TColor;
  186.     FStartDate: TDateTime;
  187.     FEndDate: TDateTime;
  188.     FOnRngSelect: TNotifyEvent;
  189.     procedure SetStartDate(Value: TDateTime);
  190.     procedure SetEndDate(Value: TDateTime);
  191.   protected
  192.     { protected declarations }
  193.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  194.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  195.   public
  196.     { public declarations }
  197.     constructor Create(AOwner: TComponent); override;
  198.     property StartDate: TDateTime read FStartDate write SetStartDate;
  199.     property EndDate: TDateTime read FEndDate write SetEndDate;
  200.   published
  201.     { published declarations }
  202.     property RangeColor: TColor read FRangeColor write FRangeColor default clBlue;
  203.     property OnRngSelect: TNotifyEvent read FOnRngSelect write FOnRngSelect;
  204.   end;
  205.  
  206.   TCalendarLabel = class(TLabel)
  207.   private
  208.     { private declarations }
  209.     FCalendarSource: TStringsCalendar;
  210.     procedure SetSource(Value: TStringsCalendar);
  211.   protected
  212.     { protected declarations }
  213.     procedure Notification(AComponent: TComponent;
  214.       Operation: TOperation); override;
  215.     procedure DateChange(Sender: TObject);
  216.   public
  217.     { public declarations }
  218.     procedure Loaded; override;
  219.     procedure UpdateLabel;
  220.   published
  221.     { published declarations }
  222.     property CalendarSource: TStringsCalendar read FCalendarSource write SetSource;
  223.   end;
  224.  
  225. implementation
  226.  
  227. {$IFDEF WIN32}
  228.   {$R ENHCALND.D32}
  229. {$ELSE}
  230.   {$R ENHCALND.D16}
  231. {$ENDIF}
  232.  
  233. { TBaseCalendar }
  234. constructor TBaseCalendar.Create(AOwner: TComponent);
  235. begin
  236.   inherited Create(AOwner);
  237.   { defaults }
  238.   ColCount := 7;
  239.   FixedCols := 0;
  240.   FixedRows := 1;
  241.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  242.   RowCount := 7;
  243.   ScrollBars := ssNone;
  244.   FBlockWeekends := false;
  245.   FBlockedColor := clGray;
  246.   FDate := Date;
  247.   FFixedHeader := true;
  248.   FEventList := TEventList.Create;
  249. end;
  250.  
  251. destructor TBaseCalendar.Destroy;
  252. begin
  253.   FEventList.Free;
  254.   inherited Destroy;
  255. end;
  256.  
  257. { Loaded override }
  258. procedure TBaseCalendar.Loaded;
  259. begin
  260.   inherited Loaded;
  261.   UpdateCalendar;
  262. end;
  263.  
  264. { Click override - sets day to the cell clicked }
  265. procedure TBaseCalendar.Click;
  266. var
  267.   TheCellText: string;
  268. begin
  269.   TheCellText := CellText[Col, Row];
  270.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  271.   inherited Click;
  272. end;
  273.  
  274. { IsLeapYear - support routine }
  275. function TBaseCalendar.IsLeapYear(AYear: Integer): Boolean;
  276. begin
  277.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  278. end;
  279.  
  280. { DaysPerMonth - protected implementation of DaysThisMonth }
  281. function TBaseCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  282. const
  283.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  284. begin
  285.   Result := DaysInMonth[AMonth];
  286.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  287. end;
  288.  
  289. { DaysThisMonth - support routine to return the days in the current month }
  290. function TBaseCalendar.DaysThisMonth: Integer;
  291. begin
  292.   Result := DaysPerMonth(Year, Month);
  293. end;
  294.  
  295. { IsWeekend - support routine to determine if a given day is a weekend }
  296. function TBaseCalendar.IsWeekend(ADay: integer): boolean;
  297. var
  298.   i, j: integer;
  299.   TheCellText: string;
  300. begin
  301.   Result := false;
  302.   for i := 0 to 6 do
  303.     for j := 1 to 6 do
  304.     begin
  305.       TheCellText := CellText[i, j];
  306.       if (TheCellText <> '') and (ADay = StrToInt(TheCellText)) then
  307.         if (i = 0) or (i = 6) then
  308.           Result := true
  309.         else Result := false;
  310.     end;
  311. end;
  312.  
  313. { MouseToCell - support routine to convert the mouse position
  314.   to cell coords }
  315. procedure TBaseCalendar.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  316. var
  317.   Coord: TGridCoord;
  318. begin
  319.   Coord := MouseCoord(X, Y);
  320.   ACol := Coord.X;
  321.   ARow := Coord.Y;
  322. end;
  323.  
  324. { DrawCell override }
  325. procedure TBaseCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  326. var
  327.   TheText: string;
  328. begin
  329.   TheText := CellText[ACol, ARow];
  330.   if ((ACol = 0) or (ACol = 6)) and FBlockWeekends and (TheText <> '') and (ARow <> 0) then
  331.     Canvas.Brush.Color := BlockedColor;
  332.   with ARect, Canvas do
  333.     TextRect(ARect, (Left + 1), (Top + 1), TheText);
  334. end;
  335.  
  336. { GetCellText - property access method to return the selected date
  337.   as a string. Acts as a storage device for the dates }
  338. function TBaseCalendar.GetCellText(ACol, ARow: Integer): string;
  339. var
  340.   DayNum: Integer;
  341. begin
  342.   if ARow = 0 then  { day names at tops of columns }
  343.     Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  344.   else
  345.   begin
  346.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  347.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  348.     else Result := IntToStr(DayNum);
  349.   end;
  350. end;
  351.  
  352. { SelectCell override - returns false for cells that shouldn't be
  353.   selected }
  354. function TBaseCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  355. begin
  356.   Result := inherited SelectCell(ACol, ARow);
  357.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  358.       Result := False;
  359.   if FBlockWeekends and ((ACol = 0) or (ACol = 6)) then
  360.       Result := False;
  361. end;
  362.  
  363. { SetCalendarDate - property access method to set calendar focused date }
  364. procedure TBaseCalendar.SetCalendarDate(Value: TDateTime);
  365. begin
  366.   if Value <> FDate then
  367.   begin
  368.     FDate := Value;
  369.     UpdateCalendar;
  370.   end;
  371. end;
  372.  
  373. { SetDateElement - internal method to get day, month or year }
  374. function TBaseCalendar.GetDateElement(Index: Integer): Integer;
  375. var
  376.   AYear, AMonth, ADay: Word;
  377. begin
  378.   DecodeDate(FDate, AYear, AMonth, ADay);
  379.   case Index of
  380.     1: Result := AYear;
  381.     2: Result := AMonth;
  382.     3: Result := ADay;
  383.     else Result := -1;
  384.   end;
  385. end;
  386.  
  387. { SetDateElement - internal method to set day, month or year }
  388. procedure TBaseCalendar.SetDateElement(Index: Integer; Value: Integer);
  389. var
  390.   AYear, AMonth, ADay: Word;
  391. begin
  392.   if Value > 0 then
  393.   begin
  394.     DecodeDate(FDate, AYear, AMonth, ADay);
  395.     case Index of
  396.       1: if AYear <> Value then AYear := Value else Exit;
  397.       2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
  398.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
  399.       else Exit;
  400.     end;
  401.     if ADay > DaysPerMonth(AYear, AMonth) then ADay := DaysPerMonth(AYear, AMonth);
  402.     FDate := EncodeDate(AYear, AMonth, ADay);
  403.     UpdateCalendar;
  404.   end;
  405. end;
  406.  
  407. { SetHookEvent - property access method to attach a HookEvent }
  408. procedure TBaseCalendar.SetHookEvent(Value: TNotifyEvent);
  409. begin
  410.   FEventList.AddEvent(Value);
  411. end;
  412.  
  413. { SetStartOfWeek - property access method to change the starting
  414.   day of the week. }
  415. procedure TBaseCalendar.SetStartOfWeek(Value: TDayOfWeek);
  416. begin
  417.   if Value <> FStartOfWeek then
  418.   begin
  419.     FStartOfWeek := Value;
  420.     UpdateCalendar;
  421.   end;
  422. end;
  423.  
  424. { SetFixedHeader - property access method to toggle fixed header }
  425. procedure TBaseCalendar.SetFixedHeader(Value: Boolean);
  426. begin
  427.   FFixedHeader := Value;
  428.   SetBounds(Left, Top, Width, Height);
  429. end;
  430.  
  431. { SetBlockWeekends - property access method to toggle
  432.   weekend blocking. }
  433. procedure TBaseCalendar.SetBlockWeekends(Value: Boolean);
  434. begin
  435.   if Value <> FBlockWeekends then
  436.   begin
  437.     FBlockWeekends := Value;
  438.     Invalidate;
  439.   end;
  440. end;
  441.  
  442. { SetBlockedColor - property access method to set the color for
  443.   blocked days. clSilver doesn't look good. }
  444. procedure TBaseCalendar.SetBlockedColor(Value: TColor);
  445. begin
  446.   if Value <> FBlockedColor then
  447.   begin
  448.     FBlockedColor := Value;
  449.     Invalidate;
  450.   end;
  451. end;
  452.  
  453. { PrevMonth }
  454. procedure TBaseCalendar.PrevMonth;
  455. begin
  456.   if Month > 1 then Month := pred(Month)
  457.   else begin
  458.     Year := Year - 1;
  459.     Month := 12;
  460.   end;
  461.   if Assigned(FMonthChange) then FMonthChange(Self, Month);
  462. end;
  463.  
  464. { NextMonth }
  465. procedure TBaseCalendar.NextMonth;
  466. begin
  467.   if Month < 12 then Month := succ(Month)
  468.   else begin
  469.     Year := Year + 1;
  470.     Month := 1;
  471.   end;
  472.   if Assigned(FMonthChange) then FMonthChange(Self, Month);
  473. end;
  474.  
  475. { NextYear }
  476. procedure TBaseCalendar.NextYear;
  477. begin
  478.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  479.   Year := Year + 1;
  480.   if Assigned(FYearChange) then FYearChange(Self, Year);
  481. end;
  482.  
  483. { PrevYear }
  484. procedure TBaseCalendar.PrevYear;
  485. begin
  486.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  487.   Year := Year - 1;
  488.   if Assigned(FYearChange) then FYearChange(Self, Year);
  489. end;
  490.  
  491. { UpdateCalendar - central "engine" }
  492. procedure TBaseCalendar.UpdateCalendar;
  493. var
  494.   AYear, AMonth, ADay: Word;
  495.   FirstDate: TDateTime;
  496.   i: integer;
  497. begin
  498.   FUpdating := True;
  499.   try
  500.     DecodeDate(FDate, AYear, AMonth, ADay);
  501.     FirstDate := EncodeDate(AYear, AMonth, 1);
  502.     { day of week for 1st of month }
  503.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - FStartOfWeek + 7) mod 7);
  504.     if FMonthOffset = 2 then FMonthOffset := -5;
  505.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  506.       False, False);
  507.     Invalidate;
  508.     { trigger OnDateChange and all HookEvents }
  509.     if Assigned(FDateChange) then FDateChange(Self, FDate);
  510.     for i := 0 to FEventList.Count-1 do
  511.     begin
  512.       FHookEvent := FEventList.Events[i];
  513.       FHookEvent(Self);
  514.     end;
  515.   finally
  516.     FUpdating := False;
  517.   end;
  518. end;
  519.  
  520. procedure TBaseCalendar.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  521. var
  522.   FixedSize: integer;
  523.   GridLines: Integer;
  524. begin
  525.   GridLines := 6 * GridLineWidth;
  526.   { set size of title row }
  527.   FixedSize := Font.Size + 8;
  528.   DefaultColWidth  := (AWidth  - GridLines) div 7;
  529.   if FFixedHeader then
  530.   begin
  531.     DefaultRowHeight := ((AHeight - FixedSize) - GridLines) div 6;
  532.     {$IFDEF WIN32}
  533.     AHeight := (((DefaultRowHeight + GridLineWidth) * 6) + 4 + (FixedSize + GridLineWidth));
  534.     {$ELSE}
  535.     AHeight := (((DefaultRowHeight + GridLineWidth) * 6) + 2 + (FixedSize + GridLineWidth));
  536.     {$ENDIF}
  537.     RowHeights[0] := FixedSize;
  538.   end else begin
  539.     DefaultRowHeight := (AHeight - GridLines) div 7;
  540.     {$IFDEF WIN32}
  541.     AHeight := (((DefaultRowHeight + GridLineWidth) * 7) + 4);
  542.     {$ELSE}
  543.     AHeight := (((DefaultRowHeight + GridLineWidth) * 7) + 2);
  544.     {$ENDIF}
  545.   end;
  546.   {$IFDEF WIN32}
  547.   AWidth := (((DefaultColWidth + GridLineWidth) * 7) + 4);
  548.   {$ELSE}
  549.   AWidth := (((DefaultColWidth + GridLineWidth) * 7) + 2);
  550.   {$ENDIF}
  551.   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  552. end;
  553.  
  554. { GetComponentImage - method to turn on-screen rendering into a bitmap.
  555.   Allows easy printing }
  556. {$IFDEF WIN32}
  557. function TBaseCalendar.GetComponentImage: TBitmap;
  558. begin
  559.   Result := TBitmap.Create;
  560.   try
  561.     Result.Width := ClientWidth+1;
  562.     Result.Height := ClientHeight+1;
  563.     Result.Canvas.Brush := Brush;
  564.     Result.Canvas.FillRect(ClientRect);
  565.     Result.Canvas.Lock;
  566.     try
  567.       PaintTo(Result.Canvas.Handle, -1, -1);
  568.     finally
  569.       Result.Canvas.Unlock;
  570.     end;
  571.   except
  572.     Result.Free;
  573.     raise;
  574.   end;
  575. end;
  576. {$ELSE}
  577. function TBaseCalendar.GetComponentImage: TBitmap;
  578. var
  579.   ScreenDC, PrintDC: HDC;
  580.   OldBits, PrintBits: HBITMAP;
  581.   PaintLParam: Longint;
  582.  
  583.   procedure PrintHandle(Handle: HWND);
  584.   var
  585.     R: TRect;
  586.     SavedIndex: Integer;
  587.   begin
  588.     SavedIndex := SaveDC(PrintDC);
  589.     WinProcs.GetClientRect(Handle, R);
  590.     MapWindowPoints(Handle, Self.Handle, R, 2);
  591.     with R do
  592.     begin
  593.       SetWindowOrgEx(PrintDC, -Left, -Top, nil);
  594.       IntersectClipRect(PrintDC, 0, 0, Right - Left, Bottom - Top);
  595.     end;
  596.     SendMessage(Handle, WM_ERASEBKGND, PrintDC, 0);
  597.     SendMessage(Handle, WM_PAINT, PrintDC, PaintLParam);
  598.     RestoreDC(PrintDC, SavedIndex);
  599.   end;
  600.  
  601. begin
  602.   Result := nil;
  603.   ScreenDC := GetDC(0);
  604.   PaintLParam := 0;
  605.   try
  606.     PrintDC := CreateCompatibleDC(ScreenDC);
  607.     { Work around an apparent bug in Windows NT }
  608.     if GetWinFlags and $4000 <> 0 then PaintLParam := PrintDC or $DEFE0000;
  609.     try
  610.       PrintBits := CreateCompatibleBitmap(ScreenDC, ClientWidth, ClientHeight);
  611.       try
  612.         OldBits := SelectObject(PrintDC, PrintBits);
  613.         try
  614.           { Clear the contents of the bitmap }
  615.           FillRect(PrintDC, ClientRect, Brush.Handle);
  616.  
  617.           { Paint form into a bitmap }
  618.           PrintHandle(Handle);
  619.         finally
  620.           SelectObject(PrintDC, OldBits);
  621.         end;
  622.         Result := TBitmap.Create;
  623.         Result.Handle := PrintBits;
  624.         PrintBits := 0;
  625.       except
  626.         Result.Free;
  627.         if PrintBits <> 0 then DeleteObject(PrintBits);
  628.         raise;
  629.       end;
  630.     finally
  631.       DeleteDC(PrintDC);
  632.     end;
  633.   finally
  634.     ReleaseDC(0, ScreenDC);
  635.   end;
  636. end;
  637. {$ENDIF}
  638.  
  639. { TStringsCalendar }
  640. constructor TStringsCalendar.Create(AOwner: TComponent);
  641. begin
  642.   inherited Create(AOwner);
  643.   { clear cells - reason: explicitly set to nil
  644.     to avoid problems later }
  645.   ClearAllDays;
  646.   { set drag methods }
  647.   OnDragDrop := AcceptDropped;
  648.   OnDragOver := CellDragOver;
  649. end;
  650.  
  651. destructor TStringsCalendar.Destroy;
  652. begin
  653.   { clear cells }
  654.   ClearAllDays;
  655.   inherited Destroy;
  656. end;
  657.  
  658. { ClearAllDays - method to clear cells }
  659. procedure TStringsCalendar.ClearAllDays;
  660. var
  661.   i, j: integer;
  662. begin
  663.   {iterate through array and free all StringLists }
  664.   for i := 0 to 6 do
  665.     for j := 0 to 6 do
  666.     begin
  667.       FCalStrings[i, j].Free;
  668.       { explicitly set to nil or else... }
  669.       FCalStrings[i, j] := nil;
  670.     end;
  671.   UpdateCalendar;
  672. end;
  673.  
  674. { AcceptDropped override }
  675. procedure TStringsCalendar.AcceptDropped(Sender, Source: TObject; X, Y: integer);
  676. var
  677.   ACol, ARow: LongInt;
  678.   Value: string;
  679. begin
  680.   { convert X and Y to Col and Row for convenience }
  681.   MouseToCell(X, Y, ACol, ARow);
  682.   { let user respond to event }
  683.   if Assigned(FOnDroppedCell) then FOnDroppedCell(Source, ACol, ARow, Value);
  684.   { if user returns a string add it to the cells list }
  685.   if Value <> '' then SetCellString(ACol, ARow, 0, Value);
  686.   { set focus to calendar }
  687.   SetFocus;
  688.   { force redraw }
  689.   Invalidate;
  690. end;
  691.  
  692. { CellDragOver override }
  693. procedure TStringsCalendar.CellDragOver(Sender, Source: TObject; X, Y: Integer;
  694.       State: TDragState; var Accept: Boolean);
  695. var
  696.   ACol, ARow: LongInt;
  697. begin
  698.   { convert X and Y to Col and Row for convenience }
  699.   MouseToCell(X, Y, ACol, ARow);
  700.   { allow user to set Accept the way they want }
  701.   if Assigned(FOnCellDragOver) then FOnCellDragOver(Sender, Source, ACol, ARow, State, Accept);
  702.   { if Accept = true then apply further logic else leave Accept = false }
  703.   if Accept = true then
  704.     if (not FUpdating) and (not FReadOnly) and (CellText[ACol, ARow] <> '') then
  705.       Accept := true
  706.     else Accept := false;
  707. end;
  708.  
  709. { DrawCell }
  710. procedure TStringsCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  711. var
  712.   Temp: TStringList;
  713.   i: integer;
  714.   StrRect: TRect;
  715.   ADate: TDateTime;
  716.   AStrings: TStringList;
  717. begin
  718.   { don't try to draw strings if they're in row 0 }
  719.   if (ARow <> 0) then
  720.   begin
  721.     if (CellText[ACol, ARow] <> '') then
  722.     begin
  723.       { accept any strings assigned in the OnNeedStrings event }
  724.       ADate := EncodeDate(Year, Month, StrToInt(CellText[ACol, ARow]));
  725.       AStrings := FCalStrings[ACol, ARow];
  726.       if Assigned(FOnNeedStrings) then FOnNeedStrings(Self, ACol, ARow, ADate, AStrings);
  727.       if AStrings <> nil then FCalStrings[ACol, ARow] := AStrings;
  728.     end;
  729.     { color occupied cells }
  730.     if (FCalStrings[ACol, ARow] <> nil) and not (gdFocused in AState) then
  731.       Canvas.Brush.Color := clYellow;
  732.     inherited DrawCell(ACol, ARow, ARect, AState);
  733.     { don't try to draw strings if they're nil }
  734.     if FCalStrings[ACol, ARow] <> nil then
  735.     begin
  736.       Temp := FCalStrings[ACol, ARow];
  737.       for i := 0 to Temp.Count-1 do
  738.       begin
  739.         { set the clipping Rect }
  740.         StrRect := Rect(ARect.Left,ARect.Top+((i+1)*Canvas.TextHeight('Test')),
  741.           ARect.Right, ARect.Bottom);
  742.         { if there is room draw the lines }
  743.         if StrRect.Bottom-StrRect.Top >= Canvas.TextHeight('Test') then
  744.           Canvas.TextRect(StrRect, StrRect.Left + 1, StrRect.Top + 1, Temp.Strings[i]);
  745.       end;
  746.     end;
  747.   end else inherited DrawCell(ACol, ARow, ARect, AState);
  748. end;
  749.  
  750. { SetCellString - adds a string to the cells stringlist based on Col
  751.   or Row or Day of month. }
  752. procedure TStringsCalendar.SetCellString(ACol, ARow, ADay: Integer; Value: string);
  753. var
  754.   i, j: integer;
  755.   TheCellText: string;
  756. begin
  757.   if (not FUpdating) and (not FReadOnly) and (CellText[ACol, ARow] <> '') then
  758.   begin
  759.     { if ADay is being used calc ACol and ARow. Doesn't matter if
  760.       ACol and ARow are <> 0 we just calc them anyway }
  761.     if ADay <> 0 then
  762.     begin
  763.       for i := 0 to 6 do
  764.         for j := 1 to 6 do
  765.         begin
  766.           TheCellText := CellText[i, j];
  767.           if (TheCellText <> '') and (ADay = StrToInt(TheCellText)) then
  768.           begin
  769.             ACol := i;
  770.             ARow := j;
  771.           end;
  772.         end;
  773.     end;
  774.     { if no StringList assigned then create one }
  775.     if FCalStrings[ACol, ARow] = nil then
  776.       FCalStrings[ACol, ARow] := TStringList.Create;
  777.     { add the line of text }
  778.     FCalStrings[ACol, ARow].Add(Value);
  779.   end;
  780. end;
  781.  
  782. procedure TStringsCalendar.SetCalStrings(ACol, ARow: integer; Value: TStringList);
  783. begin
  784.   FCalStrings[ACol, ARow] := Value;
  785. end;
  786.  
  787. { GetCalStrings - allows access to cells stringlist object. Useful
  788.   for working with TList and TMemo }
  789. function TStringsCalendar.GetCalStrings(ACol, ARow: integer): TStringList;
  790. begin
  791.   { method to return StringList as an object }
  792.   Result := FCalStrings[ACol, ARow];
  793. end;
  794.  
  795. { TRngSelCalendar }
  796. constructor TRngSelCalendar.Create(AOwner: TComponent);
  797. begin
  798.   inherited Create(AOwner);
  799.   { defaults }
  800.   FRangeColor := clBlue;
  801.   FStartDate := FDate;
  802.   FEndDate := FDate;
  803. end;
  804.  
  805. procedure TRngSelCalendar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  806. begin
  807.   inherited MouseUp(Button, Shift, X, Y);
  808.   if Button = mbLeft then
  809.   begin
  810.     if not (ssShift in Shift) then
  811.     begin
  812.       FStartDate := FDate;
  813.       FEndDate := FDate;
  814.     end else FEndDate := FDate;
  815.   end;
  816.   if Assigned(FOnRngSelect) then FOnRngSelect(Self);
  817. end;
  818.  
  819. procedure TRngSelCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  820. var
  821.   AYear, AMonth, ADay: Word;
  822.   TmpDate: TDateTime;
  823.   TheText: string;
  824. begin
  825.   TheText := CellText[ACol, ARow];
  826.   if (TheText <> '') and (ARow <> 0) then
  827.   begin
  828.     DecodeDate(FDate, AYear, AMonth, ADay);
  829.     TmpDate := EncodeDate(AYear, AMonth, StrToInt(TheText));
  830.     if (TmpDate >= FStartDate) and (TmpDate <= FEndDate)
  831.       and (FStartDate <> FEndDate) then
  832.         Canvas.Brush.Color := FRangeColor;
  833.   end;
  834.   inherited DrawCell(ACol, ARow, ARect, AState);
  835. end;
  836.  
  837. procedure TRngSelCalendar.SetStartDate(Value: TDateTime);
  838. begin
  839.   if Value <> FStartDate then
  840.   begin
  841.     FStartDate := Value;
  842.     UpdateCalendar;
  843.   end;
  844. end;
  845.  
  846. procedure TRngSelCalendar.SetEndDate(Value: TDateTime);
  847. begin
  848.   if Value <> FEndDate then
  849.   begin
  850.     FEndDate := Value;
  851.     UpdateCalendar;
  852.   end;
  853. end;
  854.  
  855. { TCalendarLabel }
  856. procedure TCalendarLabel.SetSource(Value: TStringsCalendar);
  857. begin
  858.   { set FCalendarSource := Value }
  859.   FCalendarSource := Value;
  860.   { if successful hook HookEvent }
  861.   if (FCalendarSource <> nil) then
  862.      FCalendarSource.HookEvent := DateChange;
  863.   { update label }
  864.   UpdateLabel;
  865. end;
  866.  
  867. procedure TCalendarLabel.Notification(AComponent: TComponent;
  868.       Operation: TOperation);
  869. begin
  870.   inherited Notification(AComponent, Operation);
  871.   { If the connected TBaseCalendar has been deleted, make the connection nil }
  872.   if (Operation = opRemove) and (AComponent = FCalendarSource) then
  873.      FCalendarSource := nil;
  874. end;
  875.  
  876. procedure TCalendarLabel.Loaded; 
  877. begin
  878.   inherited loaded;
  879.   { after loaded update label }
  880.   UpdateLabel;
  881. end;
  882.  
  883. procedure TCalendarLabel.DateChange(Sender: TObject);
  884. begin
  885.   { on HookEvent being triggered update label }
  886.   UpdateLabel;
  887. end;
  888.  
  889. procedure TCalendarLabel.UpdateLabel;
  890. begin
  891.   { change caption to new date }
  892.   if (FCalendarSource <> nil) then
  893.     Caption := FormatDateTime('mmmm dd, yyyy', FCalendarSource.CalendarDate);
  894. end;
  895.  
  896. end.
  897.